﻿// Crispy Plotter, a fast and easy-to-use function plotter
// Copyright (C) 2011 Konrad Kölzer
//
// Crispy Plotter is free software, see License.txt for details.

{ Provides internationalization services. }
unit Languages;

interface

uses Classes, Contnrs, Windows;

var
  KeyBack: string;
  KeyTab: string;
  KeyReturn: string;
  KeyEscape: string;
  KeySpace: string;
  KeyPrior: string;
  KeyNext: string;
  KeyEnd: string;
  KeyHome: string;
  KeyLeft: string;
  KeyUp: string;
  KeyRight: string;
  KeyDown: string;
  KeyInsert: string;
  KeyDelete: string;
  KeyControl: string;
  KeyAlt: string;
  KeyShift: string;

const
  { Native names of all languages that are currently available in CP }
  BuiltinLanguages: string =
    'cs=Čeština'#13#10 +
    'de=Deutsch'#13#10 +
    'en=English'#13#10 +
    'es=Español'#13#10 +
    'pt=Português'#13#10 +
    'zh_CN=中文(简体)'#13#10;

type
  { Selects the current application language and provides automatic translation
    of components. This class works as high level access for the
    internationalization services provided by gnugettext. }
  TLanguage = class
  private
    { Current event handler for reacting on language changes }
    FOnChangeLanguage: TNotifyEvent;
    { Current language }
    FLanguage: string;
    { List with available languages }
    FAvailableLanguages: TStrings;
    { List with the names of available languages }
    FAvailableLanguageNames: TStrings;
    { List with registered components that are translated on language change }
    FComponents: TObjectList;
    { Indicates if registered components have been translated at least once }
    FTranslated: Boolean;
    { Sets a new language and translates all components }
    procedure SetLanguage(const Value: string);
    { Translates the registered components to the selected language }
    procedure TranslateComponents;
    { Register components so they get translated on language change }
    procedure RegisterComponents(Components: array of TComponent);
    { Writes the native language names to FAvailableLanguageNames. }
    procedure FindAvailableLanguageNames;
    { Gets the native name of of the specified language }
    function GetLanguageNames(Name: string): string;
  public
    { Creates a new instance of TLanguage
      @param Components Components that should  be considered for translation }
    constructor Create(Components: array of TComponent);
    destructor Destroy; override;
    { Sets or gets the event handler that is called when the current language
      is changed. }
    property OnChangeLanguage: TNotifyEvent read FOnChangeLanguage
      write FOnChangeLanguage;
    { Returns a list with all available languages }
    property AvailableLanguages: TStrings read FAvailableLanguages;
    { Gets the native names of of the specified language }
    property LanguageNames[Name: string]: string read GetLanguageNames;
    { Gets or sets the current language }
    property Language: string read FLanguage write SetLanguage;
    { Translates a component. This method is used to translate forms that will
      not be registered, because they are dynamically created and freed. }
    procedure TranslateComponent(Component: TComponent);
    { Attempts to find one of the available language that matches the user's
      system language. If no exact match is found, then the  closest language
      is returned. }
    function GetUserLanguage: string;
  end;

var
  { Global language instance }
  Language: TLanguage;

implementation

uses Graphics, gnugettext, Dialogs, ActnMan, ActnList, SysUtils,
  ResConst, IniFiles, Menus, TB2Item, TB2Toolbar, ComCtrls, AppUtils,
  WorkSpaceView;


function TranslateShortCutToText(ShortCut: TShortCut): string;
var
  Name: string;
begin
  case WordRec(ShortCut).Lo of
    VK_BACK: Name := KeyBack;
    VK_TAB: Name := KeyTab;
    VK_RETURN: Name := KeyReturn;
    VK_ESCAPE: Name := KeyEscape;
    VK_SPACE: Name := KeySpace;
    VK_PRIOR: Name := KeyPrior;
    VK_NEXT: Name := KeyNext;
    VK_END: Name := KeyEnd;
    VK_HOME: Name := KeyHome;
    VK_LEFT: Name := KeyLeft;
    VK_UP: Name := KeyUp;
    VK_RIGHT: Name := KeyRight;
    VK_DOWN: Name := KeyDown;
    VK_INSERT: Name := KeyInsert;
    VK_DELETE: Name := KeyDelete;
    Ord('0')..Ord('9'): Name := Chr(WordRec(ShortCut).Lo);
    Ord('A')..Ord('Z'): Name := Chr(WordRec(ShortCut).Lo);
    VK_NUMPAD0..VK_NUMPAD9: Name := Chr(WordRec(ShortCut).Lo - $30);
    VK_F1..VK_F24: Name := 'F' + IntToStr(WordRec(ShortCut).Lo - $6F);
  else
    Name := '<?>';
  end;
  if Name <> '' then
  begin
    Result := '';
    if ShortCut and scShift <> 0 then Result := Result + KeyShift + '+';
    if ShortCut and scCtrl <> 0 then Result := Result + KeyControl + '+';
    if ShortCut and scAlt <> 0 then Result := Result + KeyAlt + '+';
    Result := Result + Name;
  end
  else Result := '';
end;

procedure OverwriteProcedure(OldProcedure, NewProcedure: Pointer);
var
  x: PAnsiChar;
  y: integer;
  ov2, ov: cardinal;
begin
  x := PAnsiChar(OldProcedure);
  // Disable memory protection:
  if not VirtualProtect(Pointer(x), 5, PAGE_EXECUTE_READWRITE, @ov) then
    RaiseLastOSError;
  // Overwrite pointer:
  x[0] := AnsiChar($E9); // Opcode
  y := Integer(NewProcedure) - Integer(OldProcedure) - 5;
  x[1] := AnsiChar(y and $FF);
  x[2] := AnsiChar((y shr 8) and $FF);
  x[3] := AnsiChar((y shr 16) and $FF);
  x[4] := AnsiChar((y shr 24) and $FF);
  // Reenable memory protection:
  if not VirtualProtect(Pointer(x), 5, ov, @ov2) then
    RaiseLastOSError;
end;

procedure UpdateKeyNames;
begin
  KeyBack := _('BkSp');
  KeyTab := _('Tab');
  KeyReturn := _('Enter');
  KeyEscape := _('Esc');
  KeySpace := _('Space');
  KeyPrior := _('PgUp');
  KeyNext := _('PgDn');
  KeyEnd := _('End');
  KeyHome := _('Home');
  KeyLeft := _('Left');
  KeyUp := _('Up');
  KeyRight := _('Right');
  KeyDown := _('Down');
  KeyInsert := _('Ins');
  KeyDelete := _('Del');
  KeyControl := _('Ctrl');
  KeyAlt := _('Alt');
  KeyShift := _('Shift');
end;

{ TLanguage }

constructor TLanguage.Create(Components: array of TComponent);
begin
  FLanguage := '';
  FComponents := TObjectList.Create(false);
  FAvailableLanguages := TStringList.Create;
  FAvailableLanguageNames := TStringList.Create;
  DefaultInstance.GetListOfLanguages(DefaultTextDomain, FAvailableLanguages);
  FTranslated := false;
  RegisterComponents(Components);
  { Querying native language names from Windows disabled, since retunred
    names depend on Windows version: }
  // FindAvailableLanguageNames;
  // Get native language names from built-in constans:
  FAvailableLanguageNames.Text := BuiltinLanguages;
end;

destructor TLanguage.Destroy;
begin
  FComponents.Free;
  FAvailableLanguageNames.Free;
  FAvailableLanguages.Free;
  inherited;
end;

function GetLocaleString(LocaleCode: Cardinal; LCType: Cardinal): string;
var
  Buffer : array[0..255] of char;
  Size : integer;
begin
  Size := GetLocaleInfo(LocaleCode, LCType, nil, 0);
  if Size > 255 then
    Size := 255;
  try
    GetLocaleInfo(LocaleCode, LCTYPE, Buffer, Size);
    Result := string(Buffer);
  finally
  end;
end;

function MakeLocaleId(LanguageID, SortID: Word) : Cardinal;
begin
  Result := (SortID shl 16) or LanguageID;
end;

function MakeLangId(PrimaryLanguage, SubLanguage: Word) : Cardinal;
begin
  Result := (SubLanguage shl 10) or PrimaryLanguage;
end;

procedure TLanguage.FindAvailableLanguageNames;
var
  I, J: Integer;
  LocaleID: Cardinal;
  Language, Name: string;
  Langs: TStrings;
begin
  FAvailableLanguageNames.Clear;
  Langs := TStringList.Create;
  Langs.AddStrings(FAvailableLanguages);
  // Iterate through system locales and collect native language names:
  for I := LANG_ARABIC to LANG_FAEROESE + 1 do
  begin
    LocaleID := MakeLocaleId(MakeLangId(I, SUBLANG_NEUTRAL), SORT_DEFAULT);
    Language := GetLocaleString(LocaleID, LOCALE_SISO639LANGNAME);
    if (Length(Language) > 0) then
    begin
      // Look up system locale in language list:
      for J := 0 to Langs.Count - 1 do
        if (Copy(Langs[J], 1, 2) = Language) then
        begin
          // Get and store native language name for this locale:
          Name := GetLocaleString(LocaleID, LOCALE_SNATIVELANGNAME);
          FAvailableLanguageNames.Values[Langs[J]] := Name;
          Langs.Delete(J);
          break;
        end;
    end;
  end;
  Langs.Free;
end;

function TLanguage.GetLanguageNames(Name: string): string;
begin
  Result := FAvailableLanguageNames.Values[Name];
  if Result = '' then
    Result := Name;
end;

function TLanguage.GetUserLanguage: string;
var
  AExactLanguage, AMainLanguage: string;
  I: Integer;
begin
  AExactLanguage := gnugettext.GetCurrentLanguage;
  AMainLanguage := Copy(AExactLanguage, 1, 2);
  Result := 'en';
  for I := 0 to FAvailableLanguages.Count - 1 do
  begin
    if AExactLanguage = FAvailableLanguages[I] then
    begin
      Result := AMainLanguage; // Exact language available
      exit;
    end
    else if AMainLanguage = Copy(FAvailableLanguages[I], 1, 2) then
      Result := AMainLanguage; // Main language available
  end;
end;

procedure TLanguage.RegisterComponents(Components: array of TComponent);
var
  I: Integer;
begin
  for I := Low(Components) to High(Components) do
    FComponents.Add(Components[I]);
end;

procedure TLanguage.SetLanguage(const Value: string);
begin
  FLanguage := Value;
  UseLanguage(FLanguage);
  TranslateComponents;
  UpdateKeyNames;
  if Assigned(FOnChangeLanguage) then
    FOnChangeLanguage(self);
end;

procedure TLanguage.TranslateComponent(Component: TComponent);
begin
  gnugettext.TranslateComponent(Component);
end;

procedure TLanguage.TranslateComponents;
var
  I: Integer;
begin
  if FTranslated then
    for I := 0 to FComponents.Count - 1 do
      gnugettext.RetranslateComponent(TComponent(FComponents[I]))
  else
  begin
    for I := 0 to FComponents.Count - 1 do
      gnugettext.TranslateComponent(TComponent(FComponents[I]));
    FTranslated := true;
  end;
end;

initialization
  gnugettext.TP_GlobalIgnoreClass(TFont);
  gnugettext.TP_GlobalIgnoreClassProperty(TOpenDialog, 'DefaultExt');
  gnugettext.TP_GlobalIgnoreClassProperty(TOpenDialog, 'FileName');
  gnugettext.TP_GlobalIgnoreClassProperty(TSaveDialog, 'DefaultExt');
  gnugettext.TP_GlobalIgnoreClassProperty(TSaveDialog, 'FileName');
  gnugettext.TP_GlobalIgnoreClassProperty(TWorkspaceView, 'SelectedPath');
  gnugettext.TP_GlobalIgnoreClassProperty(TWorkspaceView, 'RootPath');
  //gnugettext.TP_GlobalIgnoreClass(TTBToolbar);
  gnugettext.TP_GlobalIgnoreClass(TTBCustomItem);
  //gnugettext.TP_GlobalIgnoreClass(TAction);
  gnugettext.TP_GlobalIgnoreClass(TActionClientItem);
  gnugettext.TP_GlobalIgnoreClass(TActionManager);
  gnugettext.TP_GlobalIgnoreClass(TPopupMenu);
  gnugettext.TP_GlobalIgnoreClass(TMenuItem);
  gnugettext.TP_GlobalIgnoreClass(TStatusBar);
  gnugettext.TP_GlobalIgnoreClass(TStatusPanel);
  // Overwrite default short cut procedure with custom one:
  OverwriteProcedure(@ShortcutToText, @TranslateShortCutToText);
end.
